#!/usr/bin/perl
# Script       : mig_attachments.pl
# Author       : M. Hirschfeld
# Created      : June 17, 2005
# Last updated : June 29, 2005
# Function     : migrates Service Desk attachment folders for the 
#                implementation of FTR41990, which addresses a limitation in 
#                a number of filesystems that sets an upper limit for the 
#                number of entries per folder. Because of this limitation, 
#                large Service Desk installations may run into a scenario
#                where the attachment folder cannot accept new entries.
#
#                Path format of SD45 MR attachment folder
#                (assuming backslash is directory separator):
#                \attachmentroot\entitytype\entity-oid\attachment-oid
# 
#                Path format of SD45 "corrected" attachment folder structure
#                \attachmentroot\entitytype\entityfrags\attachment-oid-as-uuid
#                entityfrags = entity oid as 128 bit wide hexadecimal broken
#                              in parts of 3, divided by native directory 
#                              separator.
#                attachment-oid-as-uuid = attachment-oid converted to 128 bits
#                                         formatted as: 
#                                         HHHHHHHH-HHHH-HHHH-HHHH-HHHHHHHHHHHH
#                                         (where H is a hexadecimal position)
# 

#require 5.666666.0;
use File::Spec;
use File::Copy;
use Math::BigInt;
use strict;
use vars qw/%DIRCACHE/;


###############################################################################
# PRE : Argument is a a list of folder names, to which the path is defined from
#       the current working directory or is absolute.
# POST: Retrieves a list of all direct subfolders of the folders given as 
#       argument.
###############################################################################
sub getsubdirectories(@) {
   my @dirlist = @_;
   my (@entries, $curdir, $subdir);

   foreach $curdir (@dirlist) {
      next if not -d $curdir;
      opendir(DIR, $curdir);
      while (defined ($subdir = readdir(DIR))) {
         # we're not interested in the current or parent
         next if ($subdir =~/^\.$/) or ($subdir =~ /^\.\.$/);
         $subdir = File::Spec->join($curdir, $subdir);
         next if not -d $subdir;
         push(@entries, $subdir);
      }
   }
   return @entries;
} # end getsubdirectories


###############################################################################
# PRE : Argument is a folder name.
# POST: Returns all folders that the argument is a grandparent to, each folder 
#       prepended with the path to reach them from the folder given as 
#       argument.
###############################################################################
sub getgrandchildren($)
{
   my ($topdir)  = @_;
   my @topdirs   = getsubdirectories($topdir);
   my @entries   = getsubdirectories(@topdirs);
} # end getentries


###############################################################################
# PRE  : Argument is a list of folder names, to which the path is defined from
#        the current working directory or is absolute
# POST : Returns the percentage of directories not in the format expected for
#        an SD attachment.
###############################################################################
sub structural_anomaly(@) {
   my @entries   = @_;
   my @notnumber = grep !/\d{8,20}$/, @entries;

   foreach (@notnumber) {
      print "Subdir $_ does not appear to be a SD attachment folder\n";
   }
   return (scalar @entries == 0) ? 0 :
          int (((((scalar @notnumber) / (scalar @entries))) * 100) + 0.5);
} # end structural_anomaly


###############################################################################
# PRE  : First argument ($str) is a string, second argument ($n) an integer
# POST : Returns $str as a list, split in parts of $n characters wide.
###############################################################################
sub split_on_nth($$) {
   my ($str, $n) = @_;
   my @list;

   while (length($str) > 0) {
      push @list, substr($str, 0, $n);
      $str = substr($str, $n);
   }
   return @list;
} # end split_on_nth


###############################################################################
# PRE  : Argument is a string containing a number, possibly larger than
#        a scalar interpreted as an integer.
# POST : Returns 16 byte wide hexadecimal representation of number, or returns 
#        undefined it the argument (pre) was not a number.
###############################################################################
sub bigintstr2bighex($) {
   my ($number)  = @_;
   my $bigintval = new Math::BigInt($number);
   my $hexval    = $bigintval->as_hex();
   
   if ($hexval eq 'NaN') {
      undef $hexval;
   } else {
      $hexval =~ s/^0x//; 
      $hexval = sprintf('%032s', $hexval);
   }
   return $hexval;
} # end bigintstr2bighex


###############################################################################
# PRE  : Argument is a string containing a number, possibly larger than
#        a scalar interpreted as an integer.
# POST : Returns UUID format string: the number (PRE) printed as a
# hexadecimal string formatted as: HHHHHHHH-HHHH-HHHH-HHHH-HHHHHHHHHHHH
# (where H is a hexadecimal position)
###############################################################################
sub bigintstr2uuid($) {
   my ($number) = @_;
   my $uuid = bigintstr2bighex($number);
   warn "Error converting bigintstr to uuid" if length($uuid) != 32;
   if (defined $uuid) {
      $uuid = join('-', 
              substr($uuid,  0, 8),
              substr($uuid,  8, 4),
              substr($uuid, 12, 4),
              substr($uuid, 16, 4),
              substr($uuid, 20, 12)
              );
   }
   return $uuid;
} # end bigintstr2uuid


###############################################################################
# PRE  : 1st argument is a folder name that has contains service desk 
#        attachments and is identified by its entity oid and prefixed with the
#        absolute path, or a path to reach it from the current working 
#        directory.
#        2nd argument is the folder name under which the new structure will be
#        placed.
#        3rd argument is a boolean: use true if the new structure should use
#        hardlinks to the old, use false if the new structure should become a 
#        copy.
# POST : All files in the folder are copied to the new attachment structure in
#        the destination folder.
###############################################################################
sub migrate($$$) {
   my ($oldpath, $newroot, $uselink) = @_;
   my @oldparents                    = File::Spec->splitdir($oldpath);
   my $olddir  = bigintstr2bighex(pop @oldparents); # entity_oid is folder name
   my $enttype = pop @oldparents; # entity type is grandparent folder
   my @newpath = split_on_nth($olddir, 3);
   my (@entries, $newfile);
   
   if (! File::Spec->file_name_is_absolute($newroot)) {
      $newroot = File::Spec->rel2abs($newroot);
   }
   opendir(ATTDIR, $oldpath);
   while (defined (my $entry = readdir(ATTDIR))) {
      # we are not interested in the current or parent
      next if ($entry =~/^\.$/) or ($entry =~ /^\.\.$/);
      # we are not interested in subdirectories (aren't supposed to be there)
      next if -d File::Spec->join($oldpath, $entry);
      # remove extension for compressed attachments (mathilde)
      my $is_compressed = ( $entry =~ s/\.gz$// );
      # calculate SD5 UUID value for the oid of the attachment file.
      $newfile = bigintstr2uuid($entry);
      # put the extension back after determining UUID.
      if ($is_compressed && defined $newfile) {
         $newfile .= '.gz';
         $entry   .= '.gz';
      }
      my $newentry = File::Spec->catfile($newroot,$enttype,@newpath,$newfile);
      if (-e $newentry) {
         #warn "Skipping existing target '$newentry'\n";
         next;
      }
      my $oldfile  = File::Spec->catfile($oldpath, $entry);
      if (! defined $newfile) {
         warn "Error: Could not copy '$oldfile' because:\n".
              "- File '$entry' should be a number\n";
         next;
      }
      if (! defined $olddir) {
         warn "Error: Could not copy '$oldfile' because:\n".
              "- The lowest folder in '$oldpath' should be a number\n";
         next;
      }
      mkdirpathto($newentry);
      
      if ($uselink) {
         link $oldfile, $newentry
         or warn "Error: could not link from '$oldfile' to '$newentry': $!\n";
      } else {
         copy($oldfile, $newentry)
         or warn "Error: could not copy '$entry' to '$newentry'\n$!\n";
      }
   }
} # end migrate


###############################################################################
# PRE  : argument is a filename with optionally volume and path info in it.
# POST : creates directory tree up to filename in case as far as they do not 
#        exist and no earlier attempts to make them
###############################################################################
sub mkdirpathto($) {
   my ($volume, $pathto, $filename) = File::Spec->splitpath(shift);
   my @pathto                       = File::Spec->splitdir($pathto);
   for (my $idx = 0; $idx < scalar @pathto; $idx++) {
      my $dirname = (defined $volume)
                  ? File::Spec->join($volume, @pathto[0..$idx])
                  : File::Spec->join(@pathto[0..$idx]);
      if ((! -d $dirname) && (! defined $DIRCACHE{$dirname})) {
          warn "Creating directory:\n- '$dirname'\n";
          mkdir $dirname or warn "Error: could not create directory: $!\n";
          $DIRCACHE{$dirname} = 1;
      } 
   } 
} # end mkdirpathto


###############################################################################
# PRE  : List contains command line arguments.
# POST : Aborts program if list of command line arguments contains insufficient
#        or invalid values.
###############################################################################
sub process_arguments(@) {
   my @args    = @_;
   my $fname   = (File::Spec->splitpath($0))[2];
   my $uselink = 1;
   
   if ($args[0] eq '-c') {
      shift @args;
      $uselink = 0;
   }
   my $sourcedir = shift @args;
   my $targetdir = shift @args;
   if ((scalar @args > 0) || ! defined $sourcedir || ! defined $targetdir) {
      die "$fname - Migrates attachment directory structure of SD 4.5\n\n".
          "Usage: $fname [-c] <sourcedir> <targetdir>\n\n".
          "By default, this script creates hardlinks from the SD attachment ".
          "folder\nunder <sourcedir> to <targetdir>. ".
          "Use -c to create copies instead.\n";
   }
   return $uselink, $sourcedir, $targetdir;
} # end process_arguments


###############################################################################
# main
###############################################################################
{
   my ($uselink, $top, $targetdir)  = process_arguments(@ARGV);
   my @entries                      = getgrandchildren($top);
   my $pct_not_attachment           = structural_anomaly(@entries);
   # Defines the percentage of folders found to be not in the SD45 MR 
   # attachment folder structure under $top that we still consider acceptable
   # to continue (if too many are in the wrong structure, $top may be set
   # incorrectly).
   my $pct_allowed_deviant          = 50;

   if ($pct_not_attachment > $pct_allowed_deviant) { 
      die "$pct_not_attachment % of the folders in the subfolders ".
          "are not in the format of SD attachments.\n".
          "(Starting from '$top')\n".
          "Aborting\n";
   } else {
      warn "Check finished: $pct_not_attachment % of the subfolders are not ".
           "attachment folders\nContinuing...\n";
   }
   warn "Migration type: ". ($uselink ? "hardlinks ": "copies") . "\n";
   foreach my $attachmentdir (@entries) { 
      migrate($attachmentdir, $targetdir, $uselink); 
   }

} # end main
